home *** CD-ROM | disk | FTP | other *** search
/ Stone Design / Stone Design.iso / Stone_Friends / Wave / WavesWorld / Source / Libraries / tcl7.4b3 / tclTest.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-02-09  |  26.6 KB  |  936 lines
  1. /* 
  2.  * tclTest.c --
  3.  *
  4.  *    This file contains C command procedures for a bunch of additional
  5.  *    Tcl commands that are used for testing out Tcl's C interfaces.
  6.  *    These commands are not normally included in Tcl applications;
  7.  *    they're only used for testing.
  8.  *
  9.  * Copyright (c) 1993-1994 The Regents of the University of California.
  10.  * Copyright (c) 1994-1995 Sun Microsystems, Inc.
  11.  *
  12.  * See the file "license.terms" for information on usage and redistribution
  13.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14.  */
  15.  
  16. #ifndef lint
  17. static char sccsid[] = "@(#) tclTest.c 1.23 95/02/09 17:29:16";
  18. #endif /* not lint */
  19.  
  20. #include "tclInt.h"
  21. #include "tclPort.h"
  22.  
  23. /*
  24.  * The following variable is a special hack that is needed in order for
  25.  * Sun shared libraries to be used for Tcl.
  26.  */
  27.  
  28. #ifdef NEED_MATHERR
  29. extern int matherr();
  30. int *tclDummyMathPtr = (int *) matherr;
  31. #endif
  32.  
  33. /*
  34.  * Dynamic string shared by TestdcallCmd and DelCallbackProc;  used
  35.  * to collect the results of the various deletion callbacks.
  36.  */
  37.  
  38. static Tcl_DString delString;
  39. static Tcl_Interp *delInterp;
  40.  
  41. /*
  42.  * One of the following structures exists for each asynchronous
  43.  * handler created by the "testasync" command".
  44.  */
  45.  
  46. typedef struct TestAsyncHandler {
  47.     int id;                /* Identifier for this handler. */
  48.     Tcl_AsyncHandler handler;        /* Tcl's token for the handler. */
  49.     char *command;            /* Command to invoke when the
  50.                      * handler is invoked. */
  51.     struct TestAsyncHandler *nextPtr;    /* Next is list of handlers. */
  52. } TestAsyncHandler;
  53.  
  54. static TestAsyncHandler *firstHandler = NULL;
  55.  
  56. /*
  57.  * The variable below is a token for an asynchronous handler for
  58.  * interrupt signals, or NULL if none exists.
  59.  */
  60.  
  61. static Tcl_AsyncHandler intHandler;
  62.  
  63. /*
  64.  * The dynamic string below is used by the "testdstring" command
  65.  * to test the dynamic string facilities.
  66.  */
  67.  
  68. static Tcl_DString dstring;
  69.  
  70. /*
  71.  * Forward declarations for procedures defined later in this file:
  72.  */
  73.  
  74. static int        AsyncHandlerProc _ANSI_ARGS_((ClientData clientData,
  75.                 Tcl_Interp *interp, int code));
  76. static void        CmdDelProc1 _ANSI_ARGS_((ClientData clientData));
  77. static void        CmdDelProc2 _ANSI_ARGS_((ClientData clientData));
  78. static int        CmdProc1 _ANSI_ARGS_((ClientData clientData,
  79.                 Tcl_Interp *interp, int argc, char **argv));
  80. static int        CmdProc2 _ANSI_ARGS_((ClientData clientData,
  81.                 Tcl_Interp *interp, int argc, char **argv));
  82. static void        DelCallbackProc _ANSI_ARGS_((ClientData clientData,
  83.                 Tcl_Interp *interp));
  84. static int        IntHandlerProc _ANSI_ARGS_((ClientData clientData,
  85.                 Tcl_Interp *interp, int code));
  86. static void        IntProc();
  87. static void        SpecialFree _ANSI_ARGS_((char *blockPtr));
  88. static int        TestasyncCmd _ANSI_ARGS_((ClientData dummy,
  89.                 Tcl_Interp *interp, int argc, char **argv));
  90. static int        TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy,
  91.                 Tcl_Interp *interp, int argc, char **argv));
  92. static int        TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy,
  93.                 Tcl_Interp *interp, int argc, char **argv));
  94. static int        TestdcallCmd _ANSI_ARGS_((ClientData dummy,
  95.                 Tcl_Interp *interp, int argc, char **argv));
  96. static int        TestdstringCmd _ANSI_ARGS_((ClientData dummy,
  97.                 Tcl_Interp *interp, int argc, char **argv));
  98. static int        TestlinkCmd _ANSI_ARGS_((ClientData dummy,
  99.                 Tcl_Interp *interp, int argc, char **argv));
  100. static int        TestMathFunc _ANSI_ARGS_((ClientData clientData,
  101.                 Tcl_Interp *interp, Tcl_Value *args,
  102.                 Tcl_Value *resultPtr));
  103. static int        TestupvarCmd _ANSI_ARGS_((ClientData dummy,
  104.                 Tcl_Interp *interp, int argc, char **argv));
  105.  
  106. /*
  107.  *----------------------------------------------------------------------
  108.  *
  109.  * main --
  110.  *
  111.  *    This is the main program for the application.
  112.  *
  113.  * Results:
  114.  *    None: Tcl_Main never returns here, so this procedure never
  115.  *    returns either.
  116.  *
  117.  * Side effects:
  118.  *    Whatever the application does.
  119.  *
  120.  *----------------------------------------------------------------------
  121.  */
  122.  
  123. int
  124. main(argc, argv)
  125.     int argc;            /* Number of command-line arguments. */
  126.     char **argv;        /* Values of command-line arguments. */
  127. {
  128.     Tcl_Main(argc, argv);
  129.     return 0;            /* Needed only to prevent compiler warning. */
  130. }
  131.  
  132. /*
  133.  *----------------------------------------------------------------------
  134.  *
  135.  * Tcl_AppInit --
  136.  *
  137.  *    This procedure performs application-specific initialization.
  138.  *    Most applications, especially those that incorporate additional
  139.  *    packages, will have their own version of this procedure.
  140.  *
  141.  * Results:
  142.  *    Returns a standard Tcl completion code, and leaves an error
  143.  *    message in interp->result if an error occurs.
  144.  *
  145.  * Side effects:
  146.  *    Depends on the startup script.
  147.  *
  148.  *----------------------------------------------------------------------
  149.  */
  150.  
  151. int
  152. Tcl_AppInit(interp)
  153.     Tcl_Interp *interp;        /* Interpreter for application. */
  154. {
  155.     /*
  156.      * Call the init procedures for included packages.  Each call should
  157.      * look like this:
  158.      *
  159.      * if (Mod_Init(interp) == TCL_ERROR) {
  160.      *     return TCL_ERROR;
  161.      * }
  162.      *
  163.      * where "Mod" is the name of the module.
  164.      */
  165.  
  166.     if (Tcl_Init(interp) == TCL_ERROR) {
  167.     return TCL_ERROR;
  168.     }
  169.  
  170.     /*
  171.      * Create additional commands and math functions for testing Tcl.
  172.      */
  173.  
  174.     Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0,
  175.         (Tcl_CmdDeleteProc *) NULL);
  176.     Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, (ClientData) 0,
  177.         (Tcl_CmdDeleteProc *) NULL);
  178.     Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0,
  179.         (Tcl_CmdDeleteProc *) NULL);
  180.     Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0,
  181.         (Tcl_CmdDeleteProc *) NULL);
  182.     Tcl_DStringInit(&dstring);
  183.     Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0,
  184.         (Tcl_CmdDeleteProc *) NULL);
  185.     Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0,
  186.         (Tcl_CmdDeleteProc *) NULL);
  187.     Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, (ClientData) 0,
  188.         (Tcl_CmdDeleteProc *) NULL);
  189.     Tcl_CreateMathFunc(interp, "T1", 0, (Tcl_ValueType *) NULL, TestMathFunc,
  190.         (ClientData) 123);
  191.     Tcl_CreateMathFunc(interp, "T2", 0, (Tcl_ValueType *) NULL, TestMathFunc,
  192.         (ClientData) 345);
  193.  
  194.     /*
  195.      * Specify a user-specific startup file to invoke if the application
  196.      * is run interactively.  If this line is deleted then no user-specific
  197.      * startup file will be run under any conditions.
  198.      */
  199.  
  200.     tcl_RcFileName = "~/.tclshrc";
  201.     return TCL_OK;
  202. }
  203.  
  204. /*
  205.  *----------------------------------------------------------------------
  206.  *
  207.  * TestasyncCmd --
  208.  *
  209.  *    This procedure implements the "testasync" command.  It is used
  210.  *    to test the asynchronous handler facilities of Tcl.
  211.  *
  212.  * Results:
  213.  *    A standard Tcl result.
  214.  *
  215.  * Side effects:
  216.  *    Creates, deletes, and invokes handlers.
  217.  *
  218.  *----------------------------------------------------------------------
  219.  */
  220.  
  221.     /* ARGSUSED */
  222. static int
  223. TestasyncCmd(dummy, interp, argc, argv)
  224.     ClientData dummy;            /* Not used. */
  225.     Tcl_Interp *interp;            /* Current interpreter. */
  226.     int argc;                /* Number of arguments. */
  227.     char **argv;            /* Argument strings. */
  228. {
  229.     TestAsyncHandler *asyncPtr, *prevPtr;
  230.     int id, code;
  231.     static int nextId = 1;
  232.  
  233.     if (argc < 2) {
  234.     wrongNumArgs:
  235.     interp->result = "wrong # args";
  236.     return TCL_ERROR;
  237.     }
  238.     if (strcmp(argv[1], "create") == 0) {
  239.     if (argc != 3) {
  240.         goto wrongNumArgs;
  241.     }
  242.     asyncPtr = (TestAsyncHandler *) ckalloc(sizeof(TestAsyncHandler));
  243.     asyncPtr->id = nextId;
  244.     nextId++;
  245.     asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc,
  246.         (ClientData) asyncPtr);
  247.     asyncPtr->command = ckalloc((unsigned) (strlen(argv[2]) + 1));
  248.     strcpy(asyncPtr->command, argv[2]);
  249.     asyncPtr->nextPtr = firstHandler;
  250.     firstHandler = asyncPtr;
  251.     sprintf(interp->result, "%d", asyncPtr->id);
  252.     } else if (strcmp(argv[1], "delete") == 0) {
  253.     if (argc == 2) {
  254.         while (firstHandler != NULL) {
  255.         asyncPtr = firstHandler;
  256.         firstHandler = asyncPtr->nextPtr;
  257.         Tcl_AsyncDelete(asyncPtr->handler);
  258.         ckfree(asyncPtr->command);
  259.         ckfree((char *) asyncPtr);
  260.         }
  261.         return TCL_OK;
  262.     }
  263.     if (argc != 3) {
  264.         goto wrongNumArgs;
  265.     }
  266.     if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) {
  267.         return TCL_ERROR;
  268.     }
  269.     for (prevPtr = NULL, asyncPtr = firstHandler; asyncPtr != NULL;
  270.         prevPtr = asyncPtr, asyncPtr = asyncPtr->nextPtr) {
  271.         if (asyncPtr->id != id) {
  272.         continue;
  273.         }
  274.         if (prevPtr == NULL) {
  275.         firstHandler = asyncPtr->nextPtr;
  276.         } else {
  277.         prevPtr->nextPtr = asyncPtr->nextPtr;
  278.         }
  279.         Tcl_AsyncDelete(asyncPtr->handler);
  280.         ckfree(asyncPtr->command);
  281.         ckfree((char *) asyncPtr);
  282.         break;
  283.     }
  284.     } else if (strcmp(argv[1], "int") == 0) {
  285.     if (argc != 2) {
  286.         goto wrongNumArgs;
  287.     }
  288.     intHandler = Tcl_AsyncCreate(IntHandlerProc, (ClientData) interp);
  289.     signal(SIGINT, IntProc);
  290.     } else if (strcmp(argv[1], "mark") == 0) {
  291.     if (argc != 5) {
  292.         goto wrongNumArgs;
  293.     }
  294.     if ((Tcl_GetInt(interp, argv[2], &id) != TCL_OK)
  295.         || (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) {
  296.         return TCL_ERROR;
  297.     }
  298.     for (asyncPtr = firstHandler; asyncPtr != NULL;
  299.         asyncPtr = asyncPtr->nextPtr) {
  300.         if (asyncPtr->id == id) {
  301.         Tcl_AsyncMark(asyncPtr->handler);
  302.         break;
  303.         }
  304.     }
  305.     Tcl_SetResult(interp, argv[3], TCL_VOLATILE);
  306.     return code;
  307.     } else {
  308.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  309.         "\": must be create, delete, int, or mark",
  310.         (char *) NULL);
  311.     return TCL_ERROR;
  312.     }
  313.     return TCL_OK;
  314. }
  315.  
  316. static int
  317. AsyncHandlerProc(clientData, interp, code)
  318.     ClientData clientData;    /* Pointer to TestAsyncHandler structure. */
  319.     Tcl_Interp *interp;        /* Interpreter in which command was
  320.                  * executed, or NULL. */
  321.     int code;            /* Current return code from command. */
  322. {
  323.     TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData;
  324.     char *listArgv[4];
  325.     char string[20], *cmd;
  326.  
  327.     sprintf(string, "%d", code);
  328.     listArgv[0] = asyncPtr->command;
  329.     listArgv[1] = interp->result;
  330.     listArgv[2] = string;
  331.     listArgv[3] = NULL;
  332.     cmd = Tcl_Merge(3, listArgv);
  333.     code = Tcl_Eval(interp, cmd);
  334.     ckfree(cmd);
  335.     return code;
  336. }
  337.  
  338. static void
  339. IntProc()
  340. {
  341.     Tcl_AsyncMark(intHandler);
  342. }
  343.  
  344. static int
  345. IntHandlerProc(clientData, interp, code)
  346.     ClientData clientData;    /* Interpreter in which to invoke command. */
  347.     Tcl_Interp *interp;        /* Interpreter in which command was
  348.                  * executed, or NULL. */
  349.     int code;            /* Current return code from command. */
  350. {
  351.     char *listArgv[4];
  352.     char string[20], *cmd;
  353.  
  354.     interp = (Tcl_Interp *) clientData;
  355.     listArgv[0] = Tcl_GetVar(interp, "sigIntCmd", TCL_GLOBAL_ONLY);
  356.     if (listArgv[0] == NULL) {
  357.     return code;
  358.     }
  359.     listArgv[1] = interp->result;
  360.     sprintf(string, "%d", code);
  361.     listArgv[2] = string;
  362.     listArgv[3] = NULL;
  363.     cmd = Tcl_Merge(3, listArgv);
  364.     code = Tcl_Eval(interp, cmd);
  365.     ckfree(cmd);
  366.     return code;
  367. }
  368.  
  369. /*
  370.  *----------------------------------------------------------------------
  371.  *
  372.  * TestdcallCmd --
  373.  *
  374.  *    This procedure implements the "testdcall" command.  It is used
  375.  *    to test Tcl_CallWhenDeleted.
  376.  *
  377.  * Results:
  378.  *    A standard Tcl result.
  379.  *
  380.  * Side effects:
  381.  *    Creates and deletes interpreters.
  382.  *
  383.  *----------------------------------------------------------------------
  384.  */
  385.  
  386.     /* ARGSUSED */
  387. static int
  388. TestdcallCmd(dummy, interp, argc, argv)
  389.     ClientData dummy;            /* Not used. */
  390.     Tcl_Interp *interp;            /* Current interpreter. */
  391.     int argc;                /* Number of arguments. */
  392.     char **argv;            /* Argument strings. */
  393. {
  394.     int i, id;
  395.  
  396.     delInterp = Tcl_CreateInterp();
  397.     Tcl_DStringInit(&delString);
  398.     for (i = 1; i < argc; i++) {
  399.     if (Tcl_GetInt(interp, argv[i], &id) != TCL_OK) {
  400.         return TCL_ERROR;
  401.     }
  402.     if (id < 0) {
  403.         Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc,
  404.             (ClientData) (-id));
  405.     } else {
  406.         Tcl_CallWhenDeleted(delInterp, DelCallbackProc,
  407.             (ClientData) id);
  408.     }
  409.     }
  410.     Tcl_DeleteInterp(delInterp);
  411.     Tcl_DStringResult(interp, &delString);
  412.     return TCL_OK;
  413. }
  414.  
  415. /*
  416.  * The deletion callback used by TestdcallCmd:
  417.  */
  418.  
  419. static void
  420. DelCallbackProc(clientData, interp)
  421.     ClientData clientData;        /* Numerical value to append to
  422.                      * delString. */
  423.     Tcl_Interp *interp;            /* Interpreter being deleted. */
  424. {
  425.     int id = (int) clientData;
  426.     char buffer[10];
  427.  
  428.     sprintf(buffer, "%d", id);
  429.     Tcl_DStringAppendElement(&delString, buffer);
  430.     if (interp != delInterp) {
  431.     Tcl_DStringAppendElement(&delString, "bogus interpreter argument!");
  432.     }
  433. }
  434.  
  435. /*
  436.  *----------------------------------------------------------------------
  437.  *
  438.  * TestcmdinfoCmd --
  439.  *
  440.  *    This procedure implements the "testcmdinfo" command.  It is used
  441.  *    to test Tcl_GetCommandInfo, Tcl_SetCommandInfo, and command creation
  442.  *    and deletion.
  443.  *
  444.  * Results:
  445.  *    A standard Tcl result.
  446.  *
  447.  * Side effects:
  448.  *    Creates and deletes various commands and modifies their data.
  449.  *
  450.  *----------------------------------------------------------------------
  451.  */
  452.  
  453.     /* ARGSUSED */
  454. static int
  455. TestcmdinfoCmd(dummy, interp, argc, argv)
  456.     ClientData dummy;            /* Not used. */
  457.     Tcl_Interp *interp;            /* Current interpreter. */
  458.     int argc;                /* Number of arguments. */
  459.     char **argv;            /* Argument strings. */
  460. {
  461.     Tcl_CmdInfo info;
  462.  
  463.     if (argc != 3) {
  464.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  465.         " option cmdName\"", (char *) NULL);
  466.     return TCL_ERROR;
  467.     }
  468.     if (strcmp(argv[1], "create") == 0) {
  469.     Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original",
  470.         CmdDelProc1);
  471.     } else if (strcmp(argv[1], "delete") == 0) {
  472.     Tcl_DStringInit(&delString);
  473.     Tcl_DeleteCommand(interp, argv[2]);
  474.     Tcl_DStringResult(interp, &delString);
  475.     } else if (strcmp(argv[1], "get") == 0) {
  476.     if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) {
  477.         interp->result = "??";
  478.         return TCL_OK;
  479.     }
  480.     if (info.proc == CmdProc1) {
  481.         Tcl_AppendResult(interp, "CmdProc1", " ",
  482.             (char *) info.clientData, (char *) NULL);
  483.     } else if (info.proc == CmdProc2) {
  484.         Tcl_AppendResult(interp, "CmdProc2", " ",
  485.             (char *) info.clientData, (char *) NULL);
  486.     } else {
  487.         Tcl_AppendResult(interp, "unknown", (char *) NULL);
  488.     }
  489.     if (info.deleteProc == CmdDelProc1) {
  490.         Tcl_AppendResult(interp, " CmdDelProc1", " ",
  491.             (char *) info.deleteData, (char *) NULL);
  492.     } else if (info.deleteProc == CmdDelProc2) {
  493.         Tcl_AppendResult(interp, " CmdDelProc2", " ",
  494.             (char *) info.deleteData, (char *) NULL);
  495.     } else {
  496.         Tcl_AppendResult(interp, " unknown", (char *) NULL);
  497.     }
  498.     } else if (strcmp(argv[1], "modify") == 0) {
  499.     info.proc = CmdProc2;
  500.     info.clientData = (ClientData) "new_command_data";
  501.     info.deleteProc = CmdDelProc2;
  502.     info.deleteData = (ClientData) "new_delete_data";
  503.     if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) {
  504.         interp->result = "0";
  505.     } else {
  506.         interp->result = "1";
  507.     }
  508.     } else {
  509.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  510.         "\": must be create, delete, get, or modify",
  511.         (char *) NULL);
  512.     return TCL_ERROR;
  513.     }
  514.     return TCL_OK;
  515. }
  516.  
  517.     /*ARGSUSED*/
  518. static int
  519. CmdProc1(clientData, interp, argc, argv)
  520.     ClientData clientData;        /* String to return. */
  521.     Tcl_Interp *interp;            /* Current interpreter. */
  522.     int argc;                /* Number of arguments. */
  523.     char **argv;            /* Argument strings. */
  524. {
  525.     Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData,
  526.         (char *) NULL);
  527.     return TCL_OK;
  528. }
  529.  
  530.     /*ARGSUSED*/
  531. static int
  532. CmdProc2(clientData, interp, argc, argv)
  533.     ClientData clientData;        /* String to return. */
  534.     Tcl_Interp *interp;            /* Current interpreter. */
  535.     int argc;                /* Number of arguments. */
  536.     char **argv;            /* Argument strings. */
  537. {
  538.     Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData,
  539.         (char *) NULL);
  540.     return TCL_OK;
  541. }
  542.  
  543. static void
  544. CmdDelProc1(clientData)
  545.     ClientData clientData;        /* String to save. */
  546. {
  547.     Tcl_DStringInit(&delString);
  548.     Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1);
  549.     Tcl_DStringAppend(&delString, (char *) clientData, -1);
  550. }
  551.  
  552. static void
  553. CmdDelProc2(clientData)
  554.     ClientData clientData;        /* String to save. */
  555. {
  556.     Tcl_DStringInit(&delString);
  557.     Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1);
  558.     Tcl_DStringAppend(&delString, (char *) clientData, -1);
  559. }
  560.  
  561. /*
  562.  *----------------------------------------------------------------------
  563.  *
  564.  * TestcmdtokenCmd --
  565.  *
  566.  *    This procedure implements the "testcmdtoken" command.  It is used
  567.  *    to test Tcl_Command tokens and Tcl_GetCommandName.
  568.  *
  569.  * Results:
  570.  *    A standard Tcl result.
  571.  *
  572.  * Side effects:
  573.  *    Creates and deletes various commands and modifies their data.
  574.  *
  575.  *----------------------------------------------------------------------
  576.  */
  577.  
  578.     /* ARGSUSED */
  579. static int
  580. TestcmdtokenCmd(dummy, interp, argc, argv)
  581.     ClientData dummy;            /* Not used. */
  582.     Tcl_Interp *interp;            /* Current interpreter. */
  583.     int argc;                /* Number of arguments. */
  584.     char **argv;            /* Argument strings. */
  585. {
  586.     Tcl_Command token;
  587.     long int l;
  588.  
  589.     if (argc != 3) {
  590.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  591.         " option arg\"", (char *) NULL);
  592.     return TCL_ERROR;
  593.     }
  594.     if (strcmp(argv[1], "create") == 0) {
  595.     token = Tcl_CreateCommand(interp, argv[2], CmdProc1,
  596.         (ClientData) "original", (Tcl_CmdDeleteProc *) NULL);
  597.     sprintf(interp->result, "%lx", (long int) token);
  598.     } else if (strcmp(argv[1], "name") == 0) {
  599.     if (sscanf(argv[2], "%lx", &l) != 1) {
  600.         Tcl_AppendResult(interp, "bad command token \"", argv[2],
  601.             "\"", (char *) NULL);
  602.         return TCL_ERROR;
  603.     }
  604.     interp->result = Tcl_GetCommandName(interp, (Tcl_Command) l);
  605.     } else {
  606.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  607.         "\": must be create or name", (char *) NULL);
  608.     return TCL_ERROR;
  609.     }
  610.     return TCL_OK;
  611. }
  612.  
  613. /*
  614.  *----------------------------------------------------------------------
  615.  *
  616.  * TestdstringCmd --
  617.  *
  618.  *    This procedure implements the "testdstring" command.  It is used
  619.  *    to test the dynamic string facilities of Tcl.
  620.  *
  621.  * Results:
  622.  *    A standard Tcl result.
  623.  *
  624.  * Side effects:
  625.  *    Creates, deletes, and invokes handlers.
  626.  *
  627.  *----------------------------------------------------------------------
  628.  */
  629.  
  630.     /* ARGSUSED */
  631. static int
  632. TestdstringCmd(dummy, interp, argc, argv)
  633.     ClientData dummy;            /* Not used. */
  634.     Tcl_Interp *interp;            /* Current interpreter. */
  635.     int argc;                /* Number of arguments. */
  636.     char **argv;            /* Argument strings. */
  637. {
  638.     int count;
  639.  
  640.     if (argc < 2) {
  641.     wrongNumArgs:
  642.     interp->result = "wrong # args";
  643.     return TCL_ERROR;
  644.     }
  645.     if (strcmp(argv[1], "append") == 0) {
  646.     if (argc != 4) {
  647.         goto wrongNumArgs;
  648.     }
  649.     if (Tcl_GetInt(interp, argv[3], &count) != TCL_OK) {
  650.         return TCL_ERROR;
  651.     }
  652.     Tcl_DStringAppend(&dstring, argv[2], count);
  653.     } else if (strcmp(argv[1], "element") == 0) {
  654.     if (argc != 3) {
  655.         goto wrongNumArgs;
  656.     }
  657.     Tcl_DStringAppendElement(&dstring, argv[2]);
  658.     } else if (strcmp(argv[1], "end") == 0) {
  659.     if (argc != 2) {
  660.         goto wrongNumArgs;
  661.     }
  662.     Tcl_DStringEndSublist(&dstring);
  663.     } else if (strcmp(argv[1], "free") == 0) {
  664.     if (argc != 2) {
  665.         goto wrongNumArgs;
  666.     }
  667.     Tcl_DStringFree(&dstring);
  668.     } else if (strcmp(argv[1], "get") == 0) {
  669.     if (argc != 2) {
  670.         goto wrongNumArgs;
  671.     }
  672.     interp->result = Tcl_DStringValue(&dstring);
  673.     } else if (strcmp(argv[1], "gresult") == 0) {
  674.     if (argc != 3) {
  675.         goto wrongNumArgs;
  676.     }
  677.     if (strcmp(argv[2], "staticsmall") == 0) {
  678.         interp->result = "short";
  679.     } else if (strcmp(argv[2], "staticlarge") == 0) {
  680.         interp->result = "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n";
  681.     } else if (strcmp(argv[2], "free") == 0) {
  682.         interp->result = ckalloc(100);
  683.         interp->freeProc = (Tcl_FreeProc *) free;
  684.         strcpy(interp->result, "This is a malloc-ed string");
  685.     } else if (strcmp(argv[2], "special") == 0) {
  686.         interp->result = ckalloc(100);
  687.         interp->result += 4;
  688.         interp->freeProc = SpecialFree;
  689.         strcpy(interp->result, "This is a specially-allocated string");
  690.     } else {
  691.         Tcl_AppendResult(interp, "bad gresult option \"", argv[2],
  692.             "\": must be staticsmall, staticlarge, free, or special",
  693.             (char *) NULL);
  694.         return TCL_ERROR;
  695.     }
  696.     Tcl_DStringGetResult(interp, &dstring);
  697.     } else if (strcmp(argv[1], "length") == 0) {
  698.     if (argc != 2) {
  699.         goto wrongNumArgs;
  700.     }
  701.     sprintf(interp->result, "%d", Tcl_DStringLength(&dstring));
  702.     } else if (strcmp(argv[1], "result") == 0) {
  703.     if (argc != 2) {
  704.         goto wrongNumArgs;
  705.     }
  706.     Tcl_DStringResult(interp, &dstring);
  707.     } else if (strcmp(argv[1], "trunc") == 0) {
  708.     if (argc != 3) {
  709.         goto wrongNumArgs;
  710.     }
  711.     if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
  712.         return TCL_ERROR;
  713.     }
  714.     Tcl_DStringTrunc(&dstring, count);
  715.     } else if (strcmp(argv[1], "start") == 0) {
  716.     if (argc != 2) {
  717.         goto wrongNumArgs;
  718.     }
  719.     Tcl_DStringStartSublist(&dstring);
  720.     } else {
  721.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  722.         "\": must be append, element, end, free, get, length, ",
  723.         "result, trunc, or start", (char *) NULL);
  724.     return TCL_ERROR;
  725.     }
  726.     return TCL_OK;
  727. }
  728.  
  729. /*
  730.  * The procedure below is used as a special freeProc to test how well
  731.  * Tcl_DStringGetResult handles freeProc's other than free.
  732.  */
  733.  
  734. static void SpecialFree(blockPtr)
  735.     char *blockPtr;            /* Block to free. */
  736. {
  737.     ckfree(blockPtr - 4);
  738. }
  739.  
  740. /*
  741.  *----------------------------------------------------------------------
  742.  *
  743.  * TestlinkCmd --
  744.  *
  745.  *    This procedure implements the "testlink" command.  It is used
  746.  *    to test Tcl_LinkVar and related library procedures.
  747.  *
  748.  * Results:
  749.  *    A standard Tcl result.
  750.  *
  751.  * Side effects:
  752.  *    Creates and deletes various variable links, plus returns
  753.  *    values of the linked variables.
  754.  *
  755.  *----------------------------------------------------------------------
  756.  */
  757.  
  758.     /* ARGSUSED */
  759. static int
  760. TestlinkCmd(dummy, interp, argc, argv)
  761.     ClientData dummy;            /* Not used. */
  762.     Tcl_Interp *interp;            /* Current interpreter. */
  763.     int argc;                /* Number of arguments. */
  764.     char **argv;            /* Argument strings. */
  765. {
  766.     static int intVar = 43;
  767.     static int boolVar = 4;
  768.     static double realVar = 1.23;
  769.     static char *stringVar = NULL;
  770.     char buffer[TCL_DOUBLE_SPACE];
  771.     int writable, flag;
  772.  
  773.     if (argc < 2) {
  774.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  775.         " option ?arg arg arg?\"", (char *) NULL);
  776.     return TCL_ERROR;
  777.     }
  778.     if (strcmp(argv[1], "create") == 0) {
  779.     if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) {
  780.         return TCL_ERROR;
  781.     }
  782.     flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
  783.     if (Tcl_LinkVar(interp, "int", (char *) &intVar,
  784.         TCL_LINK_INT | flag) != TCL_OK) {
  785.         return TCL_ERROR;
  786.     }
  787.     if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) {
  788.         return TCL_ERROR;
  789.     }
  790.     flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
  791.     if (Tcl_LinkVar(interp, "real", (char *) &realVar,
  792.         TCL_LINK_DOUBLE | flag) != TCL_OK) {
  793.         return TCL_ERROR;
  794.     }
  795.     if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) {
  796.         return TCL_ERROR;
  797.     }
  798.     flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
  799.     if (Tcl_LinkVar(interp, "bool", (char *) &boolVar,
  800.         TCL_LINK_BOOLEAN | flag) != TCL_OK) {
  801.         return TCL_ERROR;
  802.     }
  803.     if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) {
  804.         return TCL_ERROR;
  805.     }
  806.     flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
  807.     if (Tcl_LinkVar(interp, "string", (char *) &stringVar,
  808.         TCL_LINK_STRING | flag) != TCL_OK) {
  809.         return TCL_ERROR;
  810.     }
  811.     } else if (strcmp(argv[1], "delete") == 0) {
  812.     Tcl_UnlinkVar(interp, "int");
  813.     Tcl_UnlinkVar(interp, "real");
  814.     Tcl_UnlinkVar(interp, "bool");
  815.     Tcl_UnlinkVar(interp, "string");
  816.     } else if (strcmp(argv[1], "get") == 0) {
  817.     sprintf(buffer, "%d", intVar);
  818.     Tcl_AppendElement(interp, buffer);
  819.     Tcl_PrintDouble(interp, realVar, buffer);
  820.     Tcl_AppendElement(interp, buffer);
  821.     sprintf(buffer, "%d", boolVar);
  822.     Tcl_AppendElement(interp, buffer);
  823.     Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar);
  824.     } else if (strcmp(argv[1], "set") == 0) {
  825.     if (argc != 6) {
  826.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  827.         argv[0], " ", argv[1],
  828.         "intValue realValue boolValue stringValue\"", (char *) NULL);
  829.         return TCL_ERROR;
  830.     }
  831.     if (argv[2][0] != 0) {
  832.         if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) {
  833.         return TCL_ERROR;
  834.         }
  835.     }
  836.     if (argv[3][0] != 0) {
  837.         if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) {
  838.         return TCL_ERROR;
  839.         }
  840.     }
  841.     if (argv[4][0] != 0) {
  842.         if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {
  843.         return TCL_ERROR;
  844.         }
  845.     }
  846.     if (argv[5][0] != 0) {
  847.         if (stringVar != NULL) {
  848.         ckfree(stringVar);
  849.         }
  850.         if (strcmp(argv[5], "-") == 0) {
  851.         stringVar = NULL;
  852.         } else {
  853.         stringVar = ckalloc((unsigned) (strlen(argv[5]) + 1));
  854.         strcpy(stringVar, argv[5]);
  855.         }
  856.     }
  857.     } else {
  858.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  859.         "\": should be create, delete, get, or set",
  860.         (char *) NULL);
  861.     return TCL_ERROR;
  862.     }
  863.     return TCL_OK;
  864. }
  865.  
  866. /*
  867.  *----------------------------------------------------------------------
  868.  *
  869.  * TestMathFunc --
  870.  *
  871.  *    This is a user-defined math procedure to test out math procedures
  872.  *    with no arguments.
  873.  *
  874.  * Results:
  875.  *    A normal Tcl completion code.
  876.  *
  877.  * Side effects:
  878.  *    None.
  879.  *
  880.  *----------------------------------------------------------------------
  881.  */
  882.  
  883.     /* ARGSUSED */
  884. static int
  885. TestMathFunc(clientData, interp, args, resultPtr)
  886.     ClientData clientData;        /* Integer value to return. */
  887.     Tcl_Interp *interp;            /* Not used. */
  888.     Tcl_Value *args;            /* Not used. */
  889.     Tcl_Value *resultPtr;        /* Where to store result. */
  890. {
  891.     resultPtr->type = TCL_INT;
  892.     resultPtr->intValue = (int) clientData;
  893.     return TCL_OK;
  894. }
  895.  
  896. /*
  897.  *----------------------------------------------------------------------
  898.  *
  899.  * TestupvarCmd --
  900.  *
  901.  *    This procedure implements the "testupvar2" command.  It is used
  902.  *    to test Tcl_UpVar and Tcl_UpVar2.
  903.  *
  904.  * Results:
  905.  *    A standard Tcl result.
  906.  *
  907.  * Side effects:
  908.  *    Creates or modifies an "upvar" reference.
  909.  *
  910.  *----------------------------------------------------------------------
  911.  */
  912.  
  913.     /* ARGSUSED */
  914. static int
  915. TestupvarCmd(dummy, interp, argc, argv)
  916.     ClientData dummy;            /* Not used. */
  917.     Tcl_Interp *interp;            /* Current interpreter. */
  918.     int argc;                /* Number of arguments. */
  919.     char **argv;            /* Argument strings. */
  920. {
  921.     if ((argc != 5) && (argc != 6)) {
  922.     Tcl_AppendResult(interp, "wrong # arguments: should be \"",
  923.         argv[0], " level name ?name2? dest global\"", (char *) NULL);
  924.     return TCL_ERROR;
  925.     }
  926.  
  927.     if (argc == 5) {
  928.     return Tcl_UpVar(interp, argv[1], argv[2], argv[3],
  929.         (strcmp(argv[4], "global") == 0) ? TCL_GLOBAL_ONLY : 0);
  930.     } else {
  931.     return Tcl_UpVar2(interp, argv[1], argv[2], 
  932.         (argv[3][0] == 0) ? (char *) NULL : argv[3], argv[4],
  933.         (strcmp(argv[5], "global") == 0) ? TCL_GLOBAL_ONLY : 0);
  934.     }
  935. }
  936.